home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tmh-comp.el.z / tmh-comp.el
Encoding:
Text File  |  1998-05-21  |  17.0 KB  |  550 lines
  1. ;;; tm-mh-e.el --- tm-mh-e functions for composing messages
  2.  
  3. ;; Copyright (C) 1993,1994,1995,1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;;         OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
  7. ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  8. ;; Created: 1996/2/29 (separated from tm-mh-e.el)
  9. ;; Version: $Id: tmh-comp.el,v 7.14 1997/03/18 15:05:22 morioka Exp $
  10. ;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual
  11.  
  12. ;; This file is part of tm (Tools for MIME).
  13.  
  14. ;; This program is free software; you can redistribute it and/or
  15. ;; modify it under the terms of the GNU General Public License as
  16. ;; published by the Free Software Foundation; either version 2, or (at
  17. ;; your option) any later version.
  18.  
  19. ;; This program is distributed in the hope that it will be useful, but
  20. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22. ;; General Public License for more details.
  23.  
  24. ;; You should have received a copy of the GNU General Public License
  25. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27. ;; Boston, MA 02111-1307, USA.
  28.  
  29. ;;; Code:
  30.  
  31. (require 'mh-comp)
  32. (require 'tm-edit)
  33.  
  34.  
  35. ;;; @ variable
  36. ;;;
  37.  
  38. (defvar tm-mh-e/forwcomps "forwcomps"
  39.   "Name of file to be used as a skeleton for forwarding messages.
  40. Default is \"forwcomps\".  If not a complete path name, the file
  41. is searched for first in the user's MH directory, then in the
  42. system MH lib directory.")
  43.  
  44. (defvar tm-mh-e/message-yank-function 'mh-yank-cur-msg)
  45.  
  46.  
  47. ;;; @ for tm-edit
  48. ;;;
  49.  
  50. (defun tm-mh-e::make-message (folder number)
  51.   (vector folder number)
  52.   )
  53.  
  54. (defun tm-mh-e::message/folder (message)
  55.   (elt message 0)
  56.   )
  57.  
  58. (defun tm-mh-e::message/number (message)
  59.   (elt message 1)
  60.   )
  61.  
  62. (defun tm-mh-e::message/file-name (message)
  63.   (expand-file-name
  64.    (tm-mh-e::message/number message)
  65.    (mh-expand-file-name (tm-mh-e::message/folder message))
  66.    ))
  67.  
  68. ;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
  69. ;;;    1995/11/14 (cf. [tm-ja:1096])
  70. (defun tm-mh-e/prompt-for-message (prompt folder &optional default)
  71.   (let* ((files
  72.       (directory-files (mh-expand-file-name folder) nil "^[0-9]+$")
  73.       )
  74.      (folder-buf (get-buffer folder))
  75.      (default
  76.        (if folder-buf
  77.            (save-excursion
  78.          (set-buffer folder-buf)
  79.           (let* ((show-buffer (get-buffer mh-show-buffer))
  80.              (show-buffer-file-name
  81.               (buffer-file-name show-buffer)))
  82.             (if show-buffer-file-name
  83.                 (file-name-nondirectory show-buffer-file-name)))))))
  84.     (if (or (null default)
  85.         (not (string-match "^[0-9]+$" default)))
  86.     (setq default
  87.           (if (and (string= folder mh-sent-from-folder)
  88.                mh-sent-from-msg)
  89.           (int-to-string mh-sent-from-msg)
  90.         (save-excursion
  91.           (let (cur-msg)
  92.             (if (and
  93.              (= 0 (mh-exec-cmd-quiet nil "pick" folder "cur"))
  94.              (set-buffer mh-temp-buffer)
  95.              (setq cur-msg (buffer-string))
  96.              (string-match "^[0-9]+$" cur-msg))
  97.             (substring cur-msg 0 (match-end 0))
  98.               (car files)))))))
  99.     (completing-read prompt
  100.              (let ((i 0))
  101.                (mapcar (function
  102.                 (lambda (file)
  103.                   (setq i (+ i 1))
  104.                   (list file i)
  105.                   ))
  106.                    files)
  107.                ) nil nil default)
  108.     ))
  109.  
  110. ;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
  111. ;;;    1995/11/14 (cf. [tm-ja:1096])
  112. (defun tm-mh-e/query-message (&optional message)
  113.   (let (folder number)
  114.     (if message
  115.     (progn
  116.       (setq folder (tm-mh-e::message/folder message))
  117.       (setq number (tm-mh-e::message/number message))
  118.       ))
  119.     (or (stringp folder)
  120.     (setq folder (mh-prompt-for-folder
  121.               "Message from"
  122.               (if (and (stringp mh-sent-from-folder)
  123.                    (string-match "^\\+" mh-sent-from-folder))
  124.               mh-sent-from-folder "+inbox")
  125.               nil)))
  126.     (setq number
  127.       (if (numberp number)
  128.           (number-to-string number)
  129.         (tm-mh-e/prompt-for-message "Message number: " folder)
  130.         ))
  131.     (tm-mh-e::make-message folder number)
  132.     ))
  133.  
  134. (defun tm-mh-e/insert-message (&optional message)
  135.   ;; always ignores message
  136.   (let ((article-buffer
  137.      (if (not (and (stringp mh-sent-from-folder)
  138.                (numberp mh-sent-from-msg)
  139.                ))
  140.          (cond ((and (boundp 'gnus-original-article-buffer)
  141.              (bufferp mh-sent-from-folder)
  142.              (get-buffer gnus-original-article-buffer)
  143.              )
  144.             gnus-original-article-buffer)
  145.            ((and (boundp 'gnus-article-buffer)
  146.              (get-buffer gnus-article-buffer)
  147.              (bufferp mh-sent-from-folder)
  148.              )
  149.             (save-excursion
  150.               (set-buffer gnus-article-buffer)
  151.               (if (eq major-mode 'mime/viewer-mode)
  152.               mime::preview/article-buffer
  153.             (current-buffer)
  154.             )))
  155.            ))))
  156.     (if (null article-buffer)
  157.     (tm-mh-e/insert-mail
  158.      (tm-mh-e::make-message mh-sent-from-folder mh-sent-from-msg)
  159.      )
  160.       (insert-buffer article-buffer)
  161.       (mime-editor/inserted-message-filter)
  162.       )
  163.     ))
  164.  
  165. (defun tm-mh-e/insert-mail (&optional message)
  166.   (save-excursion
  167.     (save-restriction
  168.       (let ((message-file
  169.          (tm-mh-e::message/file-name (tm-mh-e/query-message message))))
  170.     (narrow-to-region (point) (point))
  171.     (insert-file-contents message-file)
  172.     (push-mark (point-max))
  173.     (mime-editor/inserted-message-filter)
  174.     ))))
  175.  
  176. (set-alist 'mime-editor/message-inserter-alist
  177.        'mh-letter-mode (function tm-mh-e/insert-message))
  178. (set-alist 'mime-editor/mail-inserter-alist
  179.        'mh-letter-mode (function tm-mh-e/insert-mail))
  180. (set-alist 'mime-editor/mail-inserter-alist
  181.        'news-reply-mode (function tm-mh-e/insert-mail))
  182. (set-alist
  183.  'mime-editor/split-message-sender-alist
  184.  'mh-letter-mode
  185.  (function
  186.   (lambda (&optional arg)
  187.     (interactive "P")
  188.     (write-region (point-min) (point-max)
  189.           mime-editor/draft-file-name nil 'no-message)
  190.     (cond (arg
  191.        (pop-to-buffer "MH mail delivery")
  192.        (erase-buffer)
  193.        (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
  194.                    "-nodraftfolder"
  195.                    mh-send-args
  196.                    mime-editor/draft-file-name)
  197.        (goto-char (point-max))    ; show the interesting part
  198.        (recenter -1)
  199.        (sit-for 1))
  200.       (t
  201.        (apply 'mh-exec-cmd-quiet t mh-send-prog 
  202.           (mh-list-to-string
  203.            (list "-nopush" "-nodraftfolder"
  204.              "-noverbose" "-nowatch"
  205.              mh-send-args mime-editor/draft-file-name)))))
  206.     )))
  207.  
  208.  
  209. ;;; @ commands using tm-edit features
  210. ;;;
  211.  
  212. (defun tm-mh-e/edit-again (msg)
  213.   "Clean-up a draft or a message previously sent and make it resendable.
  214. Default is the current message.
  215. The variable mh-new-draft-cleaned-headers specifies the headers to remove.
  216. See also documentation for `\\[mh-send]' function."
  217.   (interactive (list (mh-get-msg-num t)))
  218.   (catch 'tag
  219.     (let* ((from-folder mh-current-folder)
  220.        (config (current-window-configuration))
  221.        code-conversion
  222.        (draft
  223.         (cond ((and mh-draft-folder (equal from-folder mh-draft-folder))
  224.            (let ((name (format "draft-%d" msg)))
  225.              (if (get-buffer name)
  226.              (throw 'tag (pop-to-buffer name))
  227.                )
  228.              (let ((filename (mh-msg-filename msg mh-draft-folder)))
  229.                (set-buffer (get-buffer-create name))
  230.                (as-binary-input-file (insert-file-contents filename))
  231.                (setq buffer-file-name filename)
  232.                (setq code-conversion t)
  233.                )
  234.              (pop-to-buffer name)
  235.              (if (re-search-forward "^-+$" nil t)
  236.              (replace-match "")
  237.              )
  238.              name))
  239.           (t
  240.            (prog1
  241.                (as-binary-input-file
  242.             (mh-read-draft "clean-up" (mh-msg-filename msg) nil)
  243.             )
  244.              (setq code-conversion t)
  245.              ))))
  246.        )
  247.       (goto-char (point-min))
  248.       (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)
  249.       (if code-conversion
  250.       (let ((cs (detect-coding-region (point-min)(point-max))))
  251.         (set-buffer-file-coding-system
  252.          (if (listp cs)
  253.          (car cs)
  254.            cs))
  255.         ))
  256.       (save-buffer)
  257.       (mime/edit-again code-conversion t t)
  258.       (goto-char (point-min))
  259.       (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil
  260.                 config)
  261.       )))
  262.  
  263. ;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
  264. ;;;    1996/2/29 (cf. [tm-ja:1643])
  265. (defun tm-mh-e/extract-rejected-mail (msg)
  266.   "Extract a letter returned by the mail system and make it re-editable.
  267. Default is the current message.  The variable mh-new-draft-cleaned-headers
  268. gives the headers to clean out of the original message."
  269.   (interactive (list (mh-get-msg-num t)))
  270.   (let ((from-folder mh-current-folder)
  271.     (config (current-window-configuration))
  272.     (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil)))
  273.     (setq buffer-read-only nil)
  274.     (goto-char (point-min))
  275.     (cond 
  276.      ((and
  277.        (re-search-forward
  278.     (concat "^\\($\\|[Cc]ontent-[Tt]ype:[ \t]+multipart/\\)") nil t)
  279.        (not (bolp))
  280.        (re-search-forward "boundary=\"\\([^\"]+\\)\"" nil t))
  281.       (let ((case-fold-search t)
  282.         (boundary (buffer-substring (match-beginning 1) (match-end 1))))
  283.     (cond
  284.      ((re-search-forward
  285.        (concat "^--" boundary "\n"
  286.            "content-type:[ \t]+"
  287.            "\\(message/rfc822\\|text/rfc822-headers\\)\n"
  288.            "\\(.+\n\\)*\n") nil t)
  289.       (delete-region (point-min) (point))
  290.       (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)
  291.       (search-forward
  292.        (concat "\n--" boundary "--\n") nil t)
  293.       (delete-region (match-beginning 0) (point-max)))
  294.      (t
  295.       (message "Seems no message/rfc822 part.")))))
  296.      ((re-search-forward mh-rejected-letter-start nil t)
  297.       (skip-chars-forward " \t\n")
  298.       (delete-region (point-min) (point))
  299.       (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil))
  300.      (t
  301.       (message "Does not appear to be a rejected letter.")))
  302.     (goto-char (point-min))
  303.     (if (re-search-forward "^-+$" nil t)
  304.     (replace-match "")
  305.       )
  306.     (mime/edit-again nil t t)
  307.     (goto-char (point-min))
  308.     (set-buffer-modified-p nil)
  309.     (mh-compose-and-send-mail draft "" from-folder msg
  310.                   (mh-get-header-field "To:")
  311.                   (mh-get-header-field "From:")
  312.                   (mh-get-header-field "Cc:")
  313.                   nil nil config)))
  314.  
  315. ;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
  316. ;;;    1995/11/14 (cf. [tm-ja:1099])
  317. (defun tm-mh-e/forward (to cc &optional msg-or-seq)
  318.   "Forward a message or message sequence as MIME message/rfc822.
  319. Defaults to displayed message. If optional prefix argument provided,
  320. then prompt for the message sequence. See also documentation for
  321. `\\[mh-send]' function."
  322.   (interactive (list (mh-read-address "To: ")
  323.              (mh-read-address "Cc: ")
  324.              (if current-prefix-arg
  325.              (mh-read-seq-default "Forward" t)
  326.                (mh-get-msg-num t)
  327.                )))
  328.   (or msg-or-seq
  329.       (setq msg-or-seq (mh-get-msg-num t)))
  330.   (let* ((folder mh-current-folder)
  331.      (config (current-window-configuration))
  332.      ;; uses "draft" for compatibility with forw.
  333.      ;; forw always leaves file in "draft" since it doesn't have -draft
  334.      (draft-name (expand-file-name "draft" mh-user-path))
  335.      (draft (cond ((or (not (file-exists-p draft-name))
  336.                (y-or-n-p "The file `draft' exists.  Discard it? "))
  337.                (mh-exec-cmd "comp"
  338.                     "-noedit" "-nowhatnowproc"
  339.                     "-form" tm-mh-e/forwcomps
  340.                     "-nodraftfolder")
  341.                (prog1
  342.                (mh-read-draft "" draft-name t)
  343.              (mh-insert-fields "To:" to "Cc:" cc)
  344.              (set-buffer-modified-p nil)))
  345.               (t
  346.                (mh-read-draft "" draft-name nil)))))
  347.     (let ((msubtype "digest")
  348.       orig-from orig-subject multipart-flag
  349.       (tag-regexp
  350.        (concat "^"
  351.            (regexp-quote (mime-make-tag "message" "rfc822"))))
  352.       )
  353.       (goto-char (point-min))
  354.       (save-excursion
  355.     (save-restriction
  356.       (goto-char (point-max))
  357.       (if (not (bolp)) (insert "\n"))
  358.       (let ((beg (point)))
  359.         (narrow-to-region beg beg)
  360.         (mh-exec-cmd-output "pick" nil folder msg-or-seq)
  361.         (if (> (count-lines (point) (point-max)) 1)
  362.         (setq multipart-flag t)
  363.           )
  364.         (while (re-search-forward "^\\([0-9]+\\)\n" nil t)
  365.           (let ((forw-msg
  366.              (buffer-substring (match-beginning 1) (match-end 1)))
  367.             (beg (match-beginning 0))
  368.             (end (match-end 0))
  369.             )
  370.         (save-restriction
  371.           (narrow-to-region beg end)
  372.           ;; modified for Emacs 18
  373.           (delete-region beg end)
  374.           (insert-file-contents
  375.            (mh-expand-file-name forw-msg
  376.                     (mh-expand-file-name folder))
  377.            )
  378.           (save-excursion
  379.             (push-mark (point-max))
  380.             (mime-editor/inserted-message-filter))
  381.           (goto-char (point-max))
  382.           )
  383.         (save-excursion
  384.           (goto-char beg)
  385.           (mime-editor/insert-tag "message" "rfc822")
  386.           )))
  387.         (delete-region (point) (point-max))
  388.         (if multipart-flag
  389.         (mime-editor/enclose-region "digest" beg (point))
  390.           ))))
  391.       (re-search-forward tag-regexp)
  392.       (forward-line 1)
  393.       (save-restriction
  394.     (narrow-to-region (point) (point-max))
  395.     (setq orig-from (mime-eword/decode-string
  396.              (mh-get-header-field "From:")))
  397.     (setq orig-subject (mime-eword/decode-string
  398.                 (mh-get-header-field "Subject:")))
  399.     )
  400.       (let ((forw-subject
  401.          (mh-forwarded-letter-subject orig-from orig-subject)))
  402.     (mh-insert-fields "Subject:" forw-subject)
  403.     (goto-char (point-min))
  404.     (re-search-forward tag-regexp)
  405.     (forward-line -1)
  406.     (delete-other-windows)
  407.     (if (numberp msg-or-seq)
  408.         (mh-add-msgs-to-seq msg-or-seq 'forwarded t)
  409.       (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t))
  410.     (mh-compose-and-send-mail draft "" folder msg-or-seq
  411.                   to forw-subject cc
  412.                   mh-note-forw "Forwarded:"
  413.                   config)))))
  414.  
  415. (cond ((not (featurep 'mh-utils))
  416.        (defun tm-mh-e::insert-letter (folder number verbatim)
  417.      (mh-insert-letter verbatim folder number)
  418.      )
  419.        )
  420.       ((and (boundp 'mh-e-version)
  421.         (string-lessp mh-e-version "5"))
  422.        (defun tm-mh-e::insert-letter (folder number verbatim)
  423.      (mh-insert-letter number folder verbatim)
  424.      )
  425.        )
  426.       (t
  427.        (defalias 'tm-mh-e::insert-letter 'mh-insert-letter)
  428.        ))
  429.  
  430. (defun tm-mh-e/insert-letter (verbatim)
  431.   "Interface to mh-insert-letter."
  432.   (interactive "P")
  433.   (let*
  434.       ((folder (mh-prompt-for-folder
  435.         "Message from"
  436.         (if (and (stringp mh-sent-from-folder)
  437.              (string-match "^\\+" mh-sent-from-folder))
  438.             mh-sent-from-folder "+inbox")
  439.         nil))
  440.        (number (tm-mh-e/prompt-for-message "Message number: " folder)))
  441.     (tm-mh-e::insert-letter folder number verbatim)))
  442.  
  443. (defun tm-mh-e/yank-cur-msg-with-no-filter ()
  444.   "Insert the current message into the draft buffer.
  445. This function makes new show-buffer from article-buffer to disable
  446. variable `mime-viewer/plain-text-preview-hook'. If you don't want to
  447. use text filters for replying message, please set it to
  448. `tm-mh-e/message-yank-function'.
  449. Prefix each non-blank line in the message with the string in
  450. `mh-ins-buf-prefix'. The entire message will be inserted if
  451. `mh-yank-from-start-of-msg' is non-nil. If this variable is nil, the
  452. portion of the message following the point will be yanked.  If
  453. `mh-delete-yanked-msg-window' is non-nil, any window displaying the
  454. yanked message will be deleted."
  455.   (interactive)
  456.   (if (and mh-sent-from-folder mh-sent-from-msg)
  457.       (let ((to-point (point))
  458.         (to-buffer (current-buffer)))
  459.     (set-buffer mh-sent-from-folder)
  460.     (if mh-delete-yanked-msg-window
  461.         (delete-windows-on mh-show-buffer))
  462.     (set-buffer mh-show-buffer)    ; Find displayed message
  463.     (let ((mh-ins-str
  464.            (if mime::preview/article-buffer
  465.            (let (mime-viewer/plain-text-preview-hook buf)
  466.              (prog1
  467.              (save-window-excursion
  468.                (set-buffer mime::preview/article-buffer)
  469.                (setq buf (mime/viewer-mode))
  470.                (buffer-string)
  471.                )
  472.                (kill-buffer buf)
  473.                ))
  474.          (buffer-string)
  475.          )))
  476.       (set-buffer to-buffer)
  477.       (save-restriction
  478.         (narrow-to-region to-point to-point)
  479.         (push-mark)
  480.         (insert mh-ins-str)
  481.         (mh-insert-prefix-string mh-ins-buf-prefix)
  482.         (insert "\n"))))
  483.     (error "There is no current message")))
  484.  
  485. (defun tm-mh-e/yank-current-message ()
  486.   "Insert the current message into the draft buffer.
  487. It uses variable `tm-mh-e/message-yank-function'
  488. to select message yanking function."
  489.   (interactive)
  490.   (let ((mh-sent-from-folder mh-sent-from-folder)
  491.     (mh-sent-from-msg mh-sent-from-msg))
  492.     (if (and (not (stringp mh-sent-from-folder))
  493.          (boundp 'gnus-article-buffer)
  494.          (get-buffer gnus-article-buffer)
  495.          (bufferp mh-sent-from-folder)
  496.          ) ; might be called from GNUS
  497.     (if (boundp 'gnus-article-copy) ; might be sgnus
  498.         (save-excursion
  499.           (gnus-copy-article-buffer)
  500.           (setq mh-sent-from-folder gnus-article-copy)
  501.           (set-buffer mh-sent-from-folder)
  502.           (setq mh-show-buffer gnus-article-copy)
  503.           )
  504.       (save-excursion
  505.         (setq mh-sent-from-folder gnus-article-buffer)
  506.         (set-buffer gnus-article-buffer)
  507.         (setq mh-show-buffer (current-buffer))
  508.         )))
  509.     (funcall tm-mh-e/message-yank-function)
  510.     ))
  511.  
  512. (substitute-key-definition
  513.  'mh-yank-cur-msg 'tm-mh-e/yank-current-message mh-letter-mode-map)
  514. (substitute-key-definition
  515.  'mh-insert-letter 'tm-mh-e/insert-letter mh-letter-mode-map)
  516.  
  517.  
  518. ;;; @ for mu-cite
  519. ;;;
  520.  
  521. (call-after-loaded
  522.  'mu-cite
  523.  (function
  524.   (lambda ()
  525.     (set-alist 'mu-cite/get-field-value-method-alist
  526.            'mh-letter-mode
  527.            (function
  528.         (lambda (name)
  529.           (if (and (stringp mh-sent-from-folder)
  530.                (numberp mh-sent-from-msg))
  531.               (save-excursion
  532.             (set-buffer mh-sent-from-folder)
  533.             (set-buffer mh-show-buffer)
  534.             (and (boundp 'mime::preview/article-buffer)
  535.                  (bufferp mime::preview/article-buffer)
  536.                  (set-buffer mime::preview/article-buffer))
  537.             (std11-field-body name)
  538.             ))
  539.           )))
  540.     )))
  541.  
  542.            
  543. ;;; @ end
  544. ;;;
  545.  
  546. (provide 'tmh-comp)
  547. (require 'tm-mh-e)
  548.  
  549. ;;; tmh-comp.el ends here
  550.